(defpackage :basic-trial
  (:use :cl)
  (:nicknames :bt)
  (:export :basic-trial
           :answers
           :input
           :tree
           :instruction-title
           :instruction-body
           :incorrect-opns
           :first-time
           :message
           :instruction-title-view
           :instruction-body-view
           :keypad-class
           :last-state
           :make-operations
           :make-operation-views
           :refresh-diagram
           :read-input
           :keypad-opened
           :keypad-closed
           :place-input-view
           :fit-input-view
           :delete-input
           :event-callback
           :convert-tree
           :log-start-keys
           :message-type-color
           :turn-on-hints-for-stage
           :fill-mode
           :select-mode
           :hints-enabled
           :keypad-target
           :update-after-navigate
           :wizard-step
           :wizard-undo
           :before-step-hook
           :before-undo-hook))

(in-package :basic-trial)

(defclass basic-trial (problem:problem exp:state)
  ((answers :initform nil :accessor answers)
   (input :initform nil :accessor input)
   (tree :initarg :tree :accessor tree)
   (equation :initarg :equation :accessor equation)
   (instruction-title :initarg :instruction-title :accessor instruction-title)
   (instruction-body :initarg :instruction-body :accessor instruction-body)
   (incorrect-opns :initform 0 :accessor incorrect-opns)
   (diagram-align :initform :center :accessor diagram-align)
   (diagram-align-y :initform nil :accessor diagram-align-y)
   (keypad-class :initform 'keypad:keypad :initarg :keypad-class :accessor keypad-class)
   (last-state-mode :initform :always :initarg :last-state-mode :accessor last-state-mode
                    :documentation "When should the last state be drawn?")
   (first-time :initform t :accessor first-time)
   ;; views that need to be defined in the inheriting gwee:component
   message
   instruction-title-view
   instruction-body-view
   last-state))

(defmethod shared-initialize :after ((obj basic-trial) slot-names &key)
  (when (and (slot-boundp obj 'equation)
             (equation obj))
    (setf (tree obj) (tree:recreate-parent-slots (d:merge-by-id (sf:equation-to-tree (equation obj)))))))

(defgeneric log-start-keys (trial)
  (:documentation "Returns any extra keys that should be tacked on to the state's START log line.")
  (:method-combination append))
(defgeneric make-operations (trial))
(defgeneric make-operation-views (trial))
(defgeneric refresh-diagram (trial view))
(defgeneric read-input (trial target))
(defgeneric fit-input-view (trial input target))
(defgeneric delete-input (trial))
(defgeneric event-callback (trial event))
(defgeneric convert-tree (trial tree)
  (:documentation "Convert the tree for use in exp:state-list-objects."))
(defgeneric keypad-opened (state node)
  (:method-combination progn :most-specific-last))
(defgeneric keypad-closed (state node)
  (:method-combination progn :most-specific-last))
(defgeneric turn-on-hints-for-stage (state))
(defgeneric hints-enabled (state)
  (:method-combination progn :most-specific-last)
  (:documentation "Called when hints were off and then they were
turned on."))

(defmethod keypad-opened progn (state node))
(defmethod keypad-closed progn (state node))

(defmethod log-start-keys append ((trial basic-trial))
  (list :tree (u:sharp-dot (tree trial)) :guided (p:guidedp trial)))

(defmethod refresh-diagram ((trial basic-trial) view)
  (tv:refresh-tree view (diagram-align trial) (diagram-align-y trial))
  ;; when an aligned diagram draws off screen, we need to realign it.
  (when (and (eq view (p:diagram trial))
             (find (diagram-align trial) '(:top :bottom))
             (or (< (geom:y (d:tree-coordinates (d:root view)))
                    (gwee:view-scroll-x view))
                 (> (+ (geom:y (d:tree-coordinates (d:root view)))
                       (geom:y (d:tree-dimensions (d:root view))))
                    (gwee:view-height view))))
    (tv:refresh-tree view :center nil)
    (setf (diagram-align-y trial)
          (ecase (diagram-align trial)
            (:top
             (geom:y (d:tree-coordinates (d:root view))))
            (:bottom
             (+ (geom:y (d:tree-coordinates (d:root view)))
                (geom:y (d:tree-dimensions (d:root view)))))))
    (tv:refresh-tree (slot-value trial 'bt:last-state)
                         (diagram-align trial)
                         (diagram-align-y trial))))

;;; implement problem API

(defun consolidate-empty-leaf-boxes (diagram)
  "Empty leaf boxes are supposed to represent the unknown and there is
only one. So, round them all up and replace them with a single one."
  (let ((unknowns (remove-duplicates
                   (d:collect-on-tree (lambda (node)
                                        (or (and (typep node 'd:multi-argument-box)
                                                 (zerop (length (tree:children node))))
                                            (and (eql (length (tree:children node)) 1)
                                                 (eq (type-of (tree:child node)) 'd:argument)
                                                 (null (tree:children (first (tree:children node)))))
                                            (> (length (tree:children node)) 1)))
                                      (d:root diagram)
                                      :only-boxes t)
                   :key 'd:id :test 'eql)))
    (d:funcall-on-tree (lambda (n)
                         (let ((u (find (d:id n) unknowns :key 'd:id :test 'eql)))
                           (when u
                             (dolist (i (tree:parents n))
                               (tree:replace-child i n u)))))
                       (d:root diagram))
    (tree:recreate-parent-slots (d:root diagram))))

(defmethod p:finish-select-mode progn ((problem basic-trial) last-eqn transformation)
  (with-slots (p:diagram last-state) problem
    ;; only display the last-state when surgery was done
    (setf (d:root last-state) (ecase (last-state-mode problem)
                                (:always last-eqn)
                                (:sticky-surgery
                                 (if (o:surgeryp transformation)
                                     last-eqn
                                     (d:root last-state)))
                                (:surgery
                                 (if (o:surgeryp transformation)
                                     last-eqn
                                     nil))))
    ;; XXX: because of the way substitutions are done during a
    ;; transformation, boxes with two parents can be copied and stored
    ;; with only one parent resulting is a garbled tree. So we need to
    ;; search for the only multi parent box that currently exists, the
    ;; X box, and replace them all with a single box.
    (consolidate-empty-leaf-boxes (p:diagram problem))
    (refresh-diagram problem last-state)
    (refresh-diagram problem p:diagram)))

(defun update-last-state (state)
  (labels ((surgery-item (item)
             (and (h:item-extra item)
                  (o:surgeryp (h:item-extra item)))))
    (with-slots (last-state last-state-mode h:current h:before) state
      (setf (d:root last-state) (ecase last-state-mode
                                  (:always
                                   (let ((item (h:last-if state (complement 'h:item-extra))))
                                     (when item (tree:copy-node (h:item-data item) t))))
                                  (:sticky-surgery
                                   ;; We want the last non-fill state
                                   ;; before the last surgery fill
                                   ;; state.
                                   (let ((item (find-if (complement 'h:item-extra)
                                                        (if (surgery-item h:current)
                                                            h:before 
                                                            (cdr (member-if #'surgery-item
                                                                            h:before))))))
                                     (when item
                                       (tree:copy-node (h:item-data item) t))))
                                  (:surgery
                                   nil)))
      (refresh-diagram state last-state))))

(defmethod p:finish-fill-mode progn ((problem basic-trial))
  (exp:lg 'fill-end :correct (h:item-correctp (h:current problem)) :new-tree (u:sharp-dot (d:root (p:diagram problem))))
  (unless (h:item-correctp (h:current problem))
    (incf (incorrect-opns problem)))
  (with-slots (input p:diagram) problem
    (when input
      (delete-input problem))
    (refresh-diagram problem p:diagram)
    (update-last-state problem)))

(defmethod event-callback ((trial basic-trial) event)
  (exp:state-dispatch-event exp:*experiment* trial event))

(exp:define-state-match select-mode ((trial basic-trial))
  ;; (print `(select-mode ,(p:mode trial)))
  (eql (p:mode trial) :select))

(exp:define-state-match fill-mode ((trial basic-trial))
  (eql (p:mode trial) :fill))

(exp:define-state-match keypad-target ((trial basic-trial))
  (when (input trial)
    (d:id (kp:target (input trial)))))

(defmethod fit-input-view ((trial basic-trial) input target)
  ;; We need to do a bit of rearranging if it doesn't fit inside the diagram area.
  (let* ((left (< (- (gwee:view-x input) (gwee:view-width input))
                  (gwee:view-scroll-x (gwee:view-parent input))))
         (right (> (+ (- (gwee:view-x input) (gwee:view-scroll-x (gwee:view-parent input)))
                      (gwee:view-width input))
                   (gwee:view-width (gwee:view-parent input))))
         (bottom (> (+ (- (gwee:view-y input) (gwee:view-scroll-y (gwee:view-parent input)))
                       (gwee:view-height input))
                    (gwee:view-height (gwee:view-parent input))))
         (newy (if bottom
                   (min
                    (- (gwee:view-height (gwee:view-parent input))
                       (gwee:view-scroll-y (gwee:view-parent input))
                       (gwee:view-height input))
                    (- (geom:centery target) (truncate (gwee:view-height input) 2)))
                   ;;(geom:y target))
                   (- (geom:centery target) (truncate (gwee:view-height input) 2)))))
    (cond
      (left
       (setf (gwee:view-x input) (geom:right target)
             (gwee:view-y input) newy))
      (right
       (setf (gwee:view-x input) (- (geom:x target) (gwee:view-width input))
             (gwee:view-y input) newy))
      (bottom
       (setf (gwee:view-x input) (geom:right target) ;;(gwee:view-x input) (- (geom:x target) (gwee:view-width input))
             (gwee:view-y input) newy)))))

(defmethod place-input-view ((trial basic-trial) input target)
  (gwee:sync-views trial)
  (setf (gwee:view-y input)
        (ecase (d:input-location target)
          (:above
           (- (geom:y target) (gwee:view-height input)))
          (:below
           (1- (geom:bottom target))))
        (gwee:view-x input)
        (- (geom:x target) (truncate (- (gwee:view-width input) (geom:width target)) 2)))
  (fit-input-view trial input target))

(defmethod delete-input ((trial basic-trial))
  (exp:lg 'hide-input-dialog :node (d:id (kp:target (input trial))))
  (gwee:delete-view (input trial))
  (let ((target (kp:target (input trial))))
    (setf (d:highlighted (kp:target (input trial))) nil
          (input trial) nil)
    (keypad-closed trial target)))

(defmethod read-input ((trial basic-trial) target)
  (let ((input (keypad:read-string (p:diagram trial)
                                   (geom:x target)
                                   (geom:bottom target)
                                   :target target
                                   :submit-callback (lambda (s)
                                                      (delete-input trial)
                                                      (p:fill-input-box trial target s)
                                                      (refresh-diagram trial (p:diagram trial)))
                                   :class (keypad-class trial))))
    (exp:lg 'show-input-dialog :node (d:id target))
    (place-input-view trial input target)
    (keypad-opened trial target)
    input))

(defclass message-text (gwee:text-area)
  ((type :initarg :type :accessor message-type))
  (:default-initargs
   :font (gwee:open-font "sans.ttf" 18)))

(defmethod message-type-color ((trial basic-trial) type)
  gwee:*default-foreground-color*)  

(defmethod message-type-color ((trial basic-trial) (type (eql :error)))
  (gwee:color 255 0 0))

(defmethod p:display-message ((trial basic-trial) type fmt &rest args)
  (let ((data (if args
                  (apply 'format nil fmt args)
                  fmt)))
    (with-slots (message) trial
      (let ((v (make-instance 'message-text
                              :width :maximum
                              :foreground (message-type-color trial type)
                              :type type
                              :data data))
            (existing (find type (gwee:view-subviews message) :key 'message-type)))
        (unless (and existing
                     (string= (gwee:view-data existing) data))
          (exp:lg 'message :type type :text data))
        (if existing
            (gwee:replace-view existing v)
            (setf (gwee:view-subviews message) (append (gwee:view-subviews message) (list v))))))))

(defmethod p:clear-message ((trial basic-trial) type)
  (with-slots (message) trial
    (if (eq type :all)
        (setf (gwee:view-subviews message) nil)
        (let ((v (find type (gwee:view-subviews message) :key 'message-type)))
          (when v
            (gwee:delete-view v))))))

(defmethod p:log ((trial basic-trial) id &rest keys &key &allow-other-keys)
  (apply 'exp:lg id keys))

;; Implement state API

(defmethod exp:state-dump append (exp (state basic-trial))
  `(:tree ,(u:sharp-dot (tree state))
    :instruction-title ,(instruction-title state)
    :instruction-body ,(instruction-body state)
    :keypad-class ,(keypad-class state)
    :last-state-mode ,(last-state-mode state)))

;; strictly speaking, a problem is independent of of exp:state, so
;; we're implementing it here...it's weird but it works, sorta.
(defmethod exp:state-dump append (exp (state p:problem))
  `(:reward-per-operation ,(p::reward-per-operation state)
    :penalty-per-fill-mistake ,(p::penalty-per-fill-mistake state)
    :penalty-per-operation ,(p::penalty-per-operation state)
    :penalty-per-hint ,(p::penalty-per-hint state)
    :guidedp ,(p:guidedp state)
    :navigate-skip-fills-p ,(p::navigate-skip-fills-p state)))

(defmethod exp:state-list-objects append (exp (state p:problem))
  (labels ((top-x (x) (gwee:view-to-top-x (p:diagram state) x))
           (top-y (y) (gwee:view-to-top-y (p:diagram state) y)))
    (list :diagram (convert-tree state (d:root (p:diagram state)))
          :diagram-layout (loop for b in (d:collect-on-tree (lambda (n) (typep n 'd:box))
                                                            (d:root (p:diagram state)))
                                unless (typep b 'd:invisible-box)
                                  collect (list (d:id b) :x (top-x (geom:x b)) :y (top-y (geom:y b))
                                                         :width (geom:width b) :height (geom:height b)
                                                         :cx (top-x (geom:centerx b)) :cy (top-y (geom:centery b)))))))

(defmethod exp:state-list-objects append (exp (state basic-trial))
  (labels ((top-x (x) (gwee:view-to-top-x (slot-value state 'last-state) x))
           (top-y (y) (gwee:view-to-top-y (slot-value state 'last-state) y)))
    (list :messages (mapcar 'gwee:view-data (gwee:view-subviews (slot-value state 'message)))
          :last-diagram (when (and (slot-value state 'last-state)
                                   (d:root (slot-value state 'last-state)))
                          (convert-tree state (d:root (slot-value state 'last-state))))
          :last-diagram-layout (when (and (slot-value state 'last-state)
                                          (d:root (slot-value state 'last-state)))
                                 (loop for b in (d:collect-on-tree (lambda (n) (typep n 'd:box))
                                                                   (d:root (slot-value state 'last-state)))
                                       unless (typep b 'd:invisible-box)
                                         collect (list (d:id b) :x (top-x (geom:x b)) :y (top-y (geom:y b))
                                                                :width (geom:width b) :height (geom:height b)
                                                                :cx (top-x (geom:centerx b)) :cy (top-y (geom:centery b)))))
          :diagram-keypad (when (input state)
                            (d:id (kp:target (input state))))
          :diagram-keypad-position (when (input state)
                                     (list :relative (d:input-location (kp:target (input state)))
                                           :x (gwee:view-x (input state))
                                           :y (gwee:view-y (input state))
                                           :width (gwee:view-width (input state))
                                           :height (gwee:view-height (input state)))))))

(defmethod exp:state-init :before (exp (state basic-trial))
  (with-slots (tree p:diagram p:operations last-state instruction-title-view instruction-body-view) state
    (setf tree (d:merge-by-id tree)
          p:operations (make-operations state)
          (d:root p:diagram) tree
          (d:root last-state) nil
          (gwee:view-data instruction-title-view) (slot-value state 'instruction-title)
          (gwee:view-data instruction-body-view) (slot-value state 'instruction-body))
    (apply 'exp:lg 'start (log-start-keys state))))

(defmethod exp:state-init :after (exp (state basic-trial))
  (with-slots (tree p:diagram diagram-align diagram-align-y) state
    (p:init state (tree:copy-node tree t))
    (refresh-diagram state (p:diagram state))
    (setf diagram-align (if (and (tree:children (d:root p:diagram))
                                 (d:quantity (first (tree:children (d:root p:diagram)))))
                            :bottom :top)
          diagram-align-y (if (eq diagram-align :top)
                              (geom:y (d:tree-coordinates (d:root p:diagram)))
                              (+ (geom:y (d:root p:diagram))
                                 (geom:height (d:root p:diagram)))))
    (p:start state)))

(defmethod exp:state-init :around (exp (state basic-trial))
  ;; FIXME: It's a hack. because state-init is called even when you go
  ;; backwards through the problems, all the setup done in state-init
  ;; happens again and screws the problem up. So skip init if we've
  ;; already done it once.
  (when (first-time state)
    (call-next-method)
    (setf (first-time state) nil)))


(defun update-after-navigate (state)
  (with-slots (input p:diagram) state
    (when input
      (gwee:delete-view input)
      (setf input nil))
    (refresh-diagram state p:diagram)
    (update-last-state state)))

(defmethod exp:state-clean-up (experiment (state basic-trial))
  )

(defmethod turn-on-hints-for-stage ((state basic-trial))
  (if (p:guidedp state)
      (exp:lg 'hint :already-guided t)
      (progn
        (exp:lg 'hint :already-guided nil)
        (incf (p:num-hints state))
        (p:clear-message state :all)
        (p:show-hint state)
        (setf (p:guidedp state) :stage)
        (refresh-diagram state (p:diagram state))
        (hints-enabled state))))

;; Ensure that this method is called last because it does not return.
(defmethod p:finish-problem :around ((state basic-trial))
  (call-next-method)
  (multiple-value-bind (reward fill-states hints fill-mistakes incorrect-operations) (p:calculate-reward state)
    (exp:lg 'end :reward reward :num-fills fill-states :hints hints :fill-mistakes fill-mistakes :incorrect-operations incorrect-operations)
    (incf (exp:reward exp:*experiment*) reward))
  (exp:state-onward exp:*experiment* state))

(defgeneric before-step-hook (state)
  (:method-combination progn :most-specific-last)
  (:documentation "This is called before a step action takes place."))

(defgeneric before-undo-hook (state)
  (:method-combination progn :most-specific-last)
  (:documentation "This is called before an undo action takes place."))

(defmethod before-step-hook progn (state))
(defmethod before-undo-hook progn (state))

(defmethod wizard-step ((state basic-trial))
  (before-step-hook state)
  (with-slots (p:diagram p:operations) state
    (let* ((tree (d:root p:diagram))
           (inputs (nreverse (d:collect-on-tree (lambda (n)
                                                  (and (string/= (u:string2 (d:quantity n))
                                                                 (u:string2 (d:answer n)))))
                                                tree
                                                :only-type 'd:input-argument)))
           (arrow (find-if 'd:arrow inputs))
           (input (or arrow (first inputs)))
           (op (guide:operation-for-selection tree p:operations))
           (selection (guide:get-selection tree p:operations)))
      (cond
        (input
         (p::fill-input-box state input (if (stringp (d:answer input))
                                            (d:answer input)
                                            (prin1-to-string (d:answer input)))))
        (op
         (p::do-operation state (o:name op)))
        (selection
         (d:funcall-on-tree (lambda (n) (setf (d:selected n) nil)) tree)
         (dolist (i selection) (setf (d:selected i) t)))
        (t (p:display-message state :wizard "nothing to step?")))
      (bt:refresh-diagram state p:diagram))))

(defmethod wizard-undo ((state basic-trial))
  (before-undo-hook state)
  (p:navigate state :back (lambda () (update-after-navigate state))))

(defmethod exp:state-unhandled-event ((exp exp:experiment) (state basic-trial) (event exp:key-press-event))
  (unless (gwee:key-modp (exp:key-press-event-key event))
    (exp:lg 'keypress :key (gwee:key-sym (exp:key-press-event-key event)) :char (gwee::key-to-character (exp:key-press-event-key event)))))

(defmethod exp:state-unhandled-event ((exp exp:experiment) (state basic-trial) (event exp:click-event))
  (exp:lg 'click :where (typecase (exp:click-event-source event)
                          (gwee:view
                           (or (loop for v = (exp:click-event-source event) then (gwee:view-parent v)
                                  while v
                                  when (gwee:view-name v)
                                  return (gwee:view-name v))
                               :experiment-window))
                          (symbol
                           (exp:click-event-source event))
                          (t
                           :unknown))
          :x (exp:click-event-x event)
          :y (exp:click-event-y event)))
